home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The PC-SIG Library 9
/
The PC-SIG Library on CD ROM - Ninth Edition.iso
/
401_500
/
DISK0426
/
DISK0426.ZIP
/
GRAPH.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-02-25
|
27KB
|
706 lines
(*************************************************************
** **
** ICS 4390 Project **
** part 2 **
** written by: **
** Fereydon Shenassa **
** Fall Quarter 1984 **
** **
** this program is a monitor which allows the use and test **
** of a 2d graphics package on a predefine object. **
** the object is defined as a triangle with vertices at **
** (-1,-1),(1,-1),(0,5) in world coordinates with a line **
** in the middle (0,-1)-(0,5). **
** **
** the operations defined are: **
** 1)rotation,translation,scaling **
** 2)window and viewport operations **
** **
** the program makes use of 3 procedures in the lida **
** package: **
** 1) openwk : initialize the workstation **
** 2) clearscreen **
** 3) line(x1,y1,x2,y2) **
** **
** the program is device independent. **
*************************************************************)
program monitor(input,output);
(*************************************************************
** constants: **
** userdimension- the number of dimensions the user **
** works with. 2 for this program. **
** dimension - userdimension + 1. **
** numhplanes - number of hyperplanes in the viewport**
** used in clipping **
** **
*************************************************************)
const
userdimension = 2;
dimension = 3;
num_hplanes = 4;
(*************************************************************
** types: **
** elementtype : type of each entry in vectors and matrix **
** columntype : one column of elements **
** matrixtype : a matrix with 1 dimension higher than **
** the user dimension **
** pointype,vectortype : same as columntype, renamed for **
** clarity **
** viewareatype: array of halfspaces for clipping **
** polygontyp : polygon represented as circular **
** linked list **
** command : a linked list representation of commands **
** which could be lines or polygons **
** **
*************************************************************)
type
(* types needed by the user to access package utilities *)
devicechoice = (hp9845,iklores,ikhires, ps300,tek4115,tek4107);
inpnames = (lightpen, digitizer, tablet);
inpclass = (locator, pick, choice, valuator, strings, stroke);
outnames = (plotter);
polygontype = (hollow, solid);
pointcoords = record
x, y : integer
end;
symbolid = array[1..6] of char;
textstring = array[1..80] of char;
ptpairarray = array[1..50] of pointcoords;
polytype = array[0..49, 1..3] of integer; (* for solid polygons *)
orientationrange = -180..180; (* angle of the text *)
anglerange = -89..89; (* angle of each character in the text *)
colorrec = record
hpred, hpgreen, hpblue : real
end;
(* types needed for the clipping operation *)
realptcoords = record
x, y : real;
end;
bezierarray = array[1..4] of realptcoords;
lines = record
a, b, c : integer; (* equation ax + by = c is used *)
orgdir : boolean; (* true implies that the origin is outside *)
end;
(* types needed by the package to process symbols *)
commandptr = ^commandentry;
commandentry = record
next : commandptr;
case tag: char of
'a' : (polnum : integer;
polptarr : ptpairarray);
'b' : (linnum : integer;
linptarr : ptpairarray);
'c' : ();
'd' : (xs, ys, xd, yd : integer); (* line *)
'e' : (setindex : integer; sred, sgreen, sblue : real);
'g' : (xt, yt, lgth : integer;
strings : textstring);
'h' : (bezierpts : bezierarray);
'i' : (isymname : symbolid;
i11, i12, i21, i22, i31, i32 : real);
'j' : (orientation : orientationrange);
'k' : (csize: integer; htwdthratio: real; tilt: anglerange);
'l' : (lstyle, lindex : integer );
'p' : (pfill : polygontype; pindex : integer);
end;
symbolptr = ^symbolrec;
symbolrec = record
name : array[1..6] of char;
start : commandptr;
next : symbolptr
end;
segtransform = array [1..3,1..2] of real;
visibility = (visible,invisible);
highlighting = (normal,highlighted);
detectability = (detectable,undetectable);
elementtype = real;
columntype = array[1..dimension] of elementtype;
matrixtype = array[1..dimension] of columntype;
pointtype = columntype;
vectortype = columntype;
segmenttype = array[1..2] of pointtype;
viewareatype = array[1..num_hplanes] of lines;
polygontyp = ^polygonelement;
polygonelement= record
point: pointtype;
next : polygontyp;
end; { polygon element }
kindtype = ( lineseg,poly);
command = ^commandnode;
commandnode = record
next : command;
case kind : kindtype of
lineseg : ( segment : segmenttype);
poly : ( polygon : polygontyp );
end; { record }
(*************************************************************
** variables: **
** mysymbol - predefined symbol used for testing the **
** routines. a triangle with a line in middle **
** myviewarea-array of halfspaces defining the viewport **
** transmatrix-global transformation matrix **
** vindowmatrix-global viewing transformtion matrix **
** x,ywindpos-location of left hand corner of window **
** printmode - toggle for print routines on /off **
** **
** x,yscreensize-resolution of device in x and y direct **
** viewminx,maxx-location of viewport in physical coord **
** x,yscreensize-size of window in x and y directions **
** **
*************************************************************)
var
(* global variables needed by the package *)
rs : char; (* control character to indicate graphics command for HP Emul *)
station : devicechoice;
fill : boolean;
hpout : file of char;
psratio : real;
hpratio : real; (* actually a constant of 4.55 *)
setfill : boolean;
esc,us : char; (*special chars for command initiation and termination
on tek4115 and tek4107 *)
polyfillcolor : integer; (* index location of fill color *)
lowres : boolean;
warnswitch : boolean;
hptable : array[0..7] of colorrec;
hplinestyletab : array[0..9] of integer;
(* variables needed to handle the window to viewport mapping *)
mapmode : boolean;
maphold : boolean;
maxscreensize : integer;
xscreensize, yscreensize : integer;
xwindsize, ywindsize : integer;
viewminx, viewmaxx : integer;
viewminy, viewmaxy : integer;
m11, m12, m21, m22, m31, m32 : real; (* for the mapping transform *)
charsize : integer;
aspect : real;
viewarea : array[1..4] of lines; (* for the clipping operation *)
intersectcoords : pointcoords;
z11, z12, z21, z22, z31, z32 : real;
recursecount : integer;
(* variables needed to handle the symbol mechanism *)
namecount : integer; (* global count of number of names used for PS 300 *)
psname : symbolid;
defmode : boolean; (* boolean for definition mode command *)
symstart : symbolptr;
thiscommand : commandptr;
nextcommand : commandptr;
lastcommand : commandptr;
mysymbol : command;
myviewarea : viewareatype;
transmatrix ,
windowmatrix : matrixtype;
xwindpos,
ywindpos : integer;
printmode : boolean;
(************************************************************
** initialization procedures **
*************************************************************)
procedure initialize ;
(*************************************************************
** initialize : **
** open the work station as a tektronix 4107 **
** and clear the screen. **
** it sets up the xscreensize and yscreensize **
** **
*************************************************************)
begin { initialize}
{ open_wk(tek4107);
clear_screen;}
end; {initialize}
procedure line(x1,y1,x2,y2 : integer );
begin
draw(x1,yscreensize-y1,x2,yscreensize-y2,white);
end; (* line *)
procedure setidentity( var matrix : matrixtype);
(*************************************************************
** setidentity: **
** reset the given matrix to the identity matrix **
** with 1's in the diagonal and 0's elsewhere **
** **
** local variables: **
** i,j : counters **
** **
*************************************************************)
var
i,j : integer;
begin { setidentity }
for i:= 1 to dimension do
begin
for j := 1 to dimension do
matrix[i,j] := 0;
matrix[i,i] := 1;
end;
end; { setidentity }
procedure define_model(var mysymbol : command );
(*************************************************************
** define_model: **
** define the triangle used in the drawing routines **
** using a polygon and a line. **
** **
** local variables: **
** element,element2 : pointers to polygon nodes **
** command2 : pointer to the line node **
** **
*************************************************************)
var
element : polygontyp;
element2: polygontyp;
command2: command;
begin
new(mysymbol);
mysymbol^.next := nil;
mysymbol^.kind := poly;
with mysymbol^ do
begin
new(polygon);
new(element);
with polygon^ do
begin { with polygon }
point[1] := -3;
point[2] := -3;
point[3] := 1;
next := element;
end; { with polygon }
element^.point[1]:= 3;
element^.point[2]:= -3 ;
element^.point[3] := 1;
new(element2);
element^.next := element2;
element2^.next := polygon;
element2^.point[1] := 0;
element2^.point[2] := 3;
element2^.point[3] := 1;
end; { with }
new(command2);
command2^.next := nil;
command2^.kind := lineseg;
command2^.segment[1,1] := 0;
command2^.segment[1,2] := -3;
command2^.segment[2,1] := 0;
command2^.segment[2,2] := 3;
mysymbol^.next := command2;
end; {define_symbol }
(************************************************************
** read and print routines **
*************************************************************)
procedure print(matrix : matrixtype);
(*************************************************************
** print: **
** utility to print a square matrix of size dimension **
** checks the printmode toggle first. if its false **
** it doesn't print anything **
** **
** local variables: **
** i,j : counters **
** **
*************************************************************)
var
i , j : integer;
begin
if printmode then
begin
writeln;
write(' ':2);
for i:= 1 to dimension do
write('*******');
writeln('*');
for i := 1 to dimension do
begin
write('*':3);
for j := 1 to dimension do
write(matrix[i,j]:6:2);
writeln('*':3);
end; { i }
write(' ':2);
for i:= 1 to dimension do
write('*******');
writeln('*');
writeln;
end;
end; { print }
procedure readvector(var vector : vectortype );
(*************************************************************
** readvector: **
** read from the input elements of a vector of size **
** userdimension. **
** **
*************************************************************)
var
i : integer;
begin { readvector }
for i := 1 to userdimension do
begin
write(i:1,'''th element ? ');
readln(vector[i]);
vector[dimension] := 1;
end;
end; { readvector }
(************************************************************
** clipping algorithm **
*************************************************************)
procedure clip_line( line : segmenttype ;
var result : segmenttype;
viewarea : viewareatype;
var outside : boolean );
(*************************************************************
** clip_line : **
** clip the given line segment to the viewarea given. **
** and return the result. set outside to true if the **
** line is completely outside the viewarea. **
** **
** local variables: **
** i : counter **
** done : flag to tell end of clipping **
** outcode: array of boolean used to keep the **
** location of each point with respect to **
** the viewarea array. **
** **
** local procedures: **
** computelocation:return true if point is outside **
** the given halfspace **
** computeintersection: compute the intersection of a **
** point and a halfspace **
** **
*************************************************************)
var
i : integer;
done : boolean;
outcode : array[1..num_hplanes,1..3] of boolean;
function compute_location(point : pointtype ; line : lines): boolean;
(************************************************************
** compute_location: **
** compute the location of the given point with **
** respect to the given line. return true if the **
** point is outside. false otherwise. **
** **
** local variables: **
** result : temporary storage of the result of puting **
** the given point in the equation of the line **
** **
*************************************************************)
var
result : real;
begin { compute_location }
with line do
begin
result := a * point[1] + b * point[2] ;
compute_location := not( ( ( result < c ) and (not orgdir ) )
or( ( result > c ) and ( orgdir ) )
or( result = c )
);
end;
end; { compute_location }
procedure compute_intersection(var segment : segmenttype ;
line : lines ;
outsidepoint : integer );
(************************************************************
** compute_intersection: **
** compute the intersection of the segment with the **
** given line. replace the result in the outside **
** endpoint. use the equation **
** y = y1 + slope *(x-x1) **
** x = x1 + 1/slope * (y-y1) **
** **
** local variables: **
** tempx,tempy : temporary intersection points **
** **
*************************************************************)
var
tempx , tempy : real;
begin { compute_intersection }
with line do
if (line.a = 0 ) then
begin
if (segment[2,2] - segment[1,2]) <> 0 then
begin
tempx := segment[1,1] + (segment[2,1] - segment[1,1])
* (line.c - segment[1,2] )
/ ( segment[2,2] - segment[1,2]);
tempy := line.c;
end
else
begin
tempx := segment[1,1];
tempy := line.c;
end;
end
else
begin
if (segment[2,1] - segment[1,1]) <> 0 then
begin
tempy := segment[1,2] + (segment[2,2] - segment[1,2])
* (line.c - segment[1,1] )
/ ( segment[2,1] - segment[1,1]);
tempx := line.c;
end
else
begin
tempy := segment[1,2] ;
tempx := line.c;
end
end;
segment[outsidepoint,1] := trunc(tempx);
segment[outsidepoint,2] := trunc(tempy);
end; { compute_intersection }
(************************************************************
** body of clip line starts here **
*************************************************************)
begin { body of clip_line }
done := false;
i := 1;
outside := false;
result := line;
while (not done ) and ( i <= num_hplanes) do
begin
outcode[i,1] := compute_location(line[1],viewarea[i]);
outcode[i,2] := compute_location(line[2],viewarea[i]);
if outcode[i,1] and outcode[i,2] then
begin
outside := true;
done := true;
end
else
outcode[i,3] := (not outcode[i,1]) and (not outcode[i,2]);
{ if both points are inside, skip that hplane, later }
i := i + 1;
end; { while }
if ( not done ) then
begin
i := 1;
while (i <=num_hplanes ) and (not done) do
begin
if (not outcode[i,3]) then
begin
outcode[i,1] := compute_location(result[1],viewarea[i]);
outcode[i,2] := compute_location(result[2],viewarea[i]);
if (outcode[i,1] and outcode[i,2] ) then
begin
done := true;
outside := true;
end
else
begin
if outcode[i,1] or outcode[i,2] then
if ( outcode[i,1] ) then
compute_intersection(result,viewarea[i],1)
else
compute_intersection(result,viewarea[i],2);
end;
end;
i := i + 1;
end; { while not done }
end; { if not done }
end; { clip_line }
(************************************************************
** matrix operation routines **
*************************************************************)
procedure concatenate(leftmatrix,rightmatrix : matrixtype;
var resultmatrix: matrixtype);
(************************************************************
** concatenate: **
** multiply the left and right matrices and put the **
** result in resultmatrix. **
** **
** local variables: **
** i,j,k : counters **
** temp : temporary storage area for sum of a column **
** **
*************************************************************)
var
i,j,k : integer;
temp : elementtype;
begin { concatenate }
for i := 1 to dimension do
begin
for j := 1 to dimension do
begin
temp := 0;
for k := 1 to dimension do
temp := temp + leftmatrix[i,k] * rightmatrix[k,j] ;
resultmatrix[i,j] := temp ;
end;
end;
end; { concatenate }
procedure applymatrix(var segment : segmenttype;
matrix : matrixtype );
(************************************************************
** applymatrix: **
** multiply the segment vector by the matrix and return **
** the result in the segment. **
** **
** local variables: **
** i : counter **
** tempseg: temporary result of multiplication. **
** **
*************************************************************)
var
i : integer;
tempseg : segmenttype;
begin { applymatrix }
for i := 1 to 2 do
begin
tempseg[i,1] := segment[i,1] * matrix[1,1]+
segment[i,2] * matrix[2,1]+
+ matrix[3,1];
tempseg[i,2] := segment[i,1] * matrix[1,2]+
segment[i,2] * matrix[2,2]+
+ matrix[3,2];
tempseg[i,3] := 1;
end; { for }
segment := tempseg;
end; {applymatrix }
(************************************************************
** transformation routines **
*************************************************************)
procedure translate(var inputmatrix :matrixtype;
transvector : vectortype );
(************************************************************
** translate: **
** add a translation by a translation vector to the **
** inputmatrix. **
** **
** local variables: **
** i : counters **
** **
*************************************************************)
var
i : integer;
begin { translate}
for i := 1 to userdimension do
inputmatrix[dimension,i] := inputmatrix[dimension,i]
+transvector[i];
end; { translate }
procedure scale(var inputmatrix : matrixtype ;
scalevector : vectortype );
(************************************************************
** scale: **
** concatenate a scaling matrix of value scalevector **
** to the input matrix. the procedure is optimized **
** **
** local variables: **
** i,j : counters **
** **
*************************************************************)
var
i , j : integer;
begin { scale }
for i := 1 to userdimension do
for j := 1 to dimension do
inputmatrix[j,i] := inputmatrix[j,i] * scalevector[i] ;
end; { scale }
{$i graph2.pas }
:= 1 to dimension do
inputmatrix[j,i] := inputmatrix[j,i] * scalevector
